home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / calendar / cal-mayan.el < prev    next >
Encoding:
Text File  |  1995-03-25  |  15.3 KB  |  386 lines
  1. ;;; cal-mayan.el --- calendar functions for the Mayan calendars.
  2.  
  3. ;; Copyright (C) 1992, 1993 Free Software Foundation, Inc.
  4.  
  5. ;; Author: Stewart M. Clamen <clamen@cs.cmu.edu>
  6. ;;    Edward M. Reingold <reingold@cs.uiuc.edu>
  7. ;; Keywords: calendar
  8. ;; Human-Keywords: Mayan calendar, Maya, calendar, diary
  9.  
  10. ;; This file is part of XEmacs.
  11.  
  12. ;; XEmacs is free software; you can redistribute it and/or modify it
  13. ;; under the terms of the GNU General Public License as published by
  14. ;; the Free Software Foundation; either version 2, or (at your option)
  15. ;; any later version.
  16.  
  17. ;; XEmacs is distributed in the hope that it will be useful, but
  18. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  19. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20. ;; General Public License for more details.
  21.  
  22. ;; You should have received a copy of the GNU General Public License
  23. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  24. ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26. ;;; Commentary:
  27.  
  28. ;; This collection of functions implements the features of calendar.el and
  29. ;; diary.el that deal with the Mayan calendar.  It was written jointly by
  30.  
  31. ;;  Stewart M. Clamen                School of Computer Science
  32. ;;  clamen@cs.cmu.edu                Carnegie Mellon University
  33. ;;                                   5000 Forbes Avenue
  34. ;;                                   Pittsburgh, PA 15213
  35.  
  36. ;; and
  37.  
  38. ;;  Edward M. Reingold               Department of Computer Science
  39. ;;  (217) 333-6733                   University of Illinois at Urbana-Champaign
  40. ;;  reingold@cs.uiuc.edu             1304 West Springfield Avenue
  41. ;;                                   Urbana, Illinois 61801
  42.  
  43. ;; Comments, improvements, and bug reports should be sent to Reingold.
  44.  
  45. ;; Technical details of the Mayan calendrical calculations can be found in
  46. ;; ``Calendrical Calculations, Part II: Three Historical Calendars''
  47. ;; by E. M. Reingold,  N. Dershowitz, and S. M. Clamen,
  48. ;; Software--Practice and Experience, Volume 23, Number 4 (April, 1993),
  49. ;; pages 383-404.
  50.  
  51. ;;; Code:
  52.  
  53. (require 'calendar)
  54.  
  55. (defun mayan-adjusted-mod (m n)
  56.   "Non-negative remainder of M/N with N instead of 0."
  57.   (1+ (mod (1- m) n)))
  58.  
  59. (defconst calendar-mayan-days-before-absolute-zero 1137140
  60.   "Number of days of the Mayan calendar epoch before absolute day 0.
  61. According to the Goodman-Martinez-Thompson correlation.  This correlation is
  62. not universally accepted, as it still a subject of astro-archeological
  63. research.  Using 1232041 will give you Spinden's correlation; using
  64. 1142840 will give you Hochleitner's correlation.")
  65.  
  66. (defconst calendar-mayan-haab-at-epoch '(8 . 18)
  67.   "Mayan haab date at the epoch.")
  68.  
  69. (defconst calendar-mayan-haab-month-name-array
  70.   ["Pop" "Uo" "Zip" "Zotz" "Tzec" "Xul" "Yaxkin" "Mol" "Chen" "Yax"
  71.    "Zac" "Ceh" "Mac" "Kankin" "Muan" "Pax" "Kayab" "Cumku"])
  72.  
  73. (defconst calendar-mayan-tzolkin-at-epoch '(4 . 20)
  74.   "Mayan tzolkin date at the epoch.")
  75.  
  76. (defconst calendar-mayan-tzolkin-names-array
  77.   ["Imix" "Ik" "Akbal" "Kan" "Chicchan" "Cimi" "Manik" "Lamat" "Muluc" "Oc"
  78.    "Chuen" "Eb" "Ben" "Ix" "Men" "Cib" "Caban" "Etznab" "Cauac" "Ahau"])
  79.  
  80. (defun calendar-mayan-long-count-from-absolute (date)
  81.   "Compute the Mayan long count corresponding to the absolute DATE."
  82.   (let ((long-count (+ date calendar-mayan-days-before-absolute-zero)))
  83.     (let* ((baktun (/ long-count 144000))
  84.            (remainder (% long-count 144000))
  85.            (katun (/ remainder 7200))
  86.            (remainder (% remainder 7200))
  87.            (tun (/ remainder 360))
  88.            (remainder (% remainder 360))
  89.            (uinal (/ remainder 20))
  90.            (kin (% remainder 20)))
  91.       (list baktun katun tun uinal kin))))
  92.  
  93. (defun calendar-mayan-long-count-to-string (mayan-long-count)
  94.   "Convert MAYAN-LONG-COUNT into traditional written form."
  95.   (apply 'format (cons "%s.%s.%s.%s.%s" mayan-long-count)))
  96.  
  97. (defun calendar-string-to-mayan-long-count (str)
  98.   "Given STR, a string of format \"%d.%d.%d.%d.%d\", return list of nums."
  99.   (let ((rlc nil)
  100.         (c (length str))
  101.         (cc 0))
  102.     (condition-case condition
  103.         (progn
  104.           (while (< cc c)
  105.         (let* ((start (string-match "[0-9]+" str cc))
  106.            (end (match-end 0))
  107.            datum)
  108.           (setq datum (read (substring str start end)))
  109.           (setq rlc (cons datum rlc))
  110.           (setq cc end)))
  111.           (if (not (= (length rlc) 5)) (signal 'invalid-read-syntax nil)))
  112.       (invalid-read-syntax nil))
  113.     (reverse rlc)))
  114.  
  115. (defun calendar-mayan-haab-from-absolute (date)
  116.   "Convert absolute DATE into a Mayan haab date (a pair)."
  117.   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
  118.          (day-of-haab
  119.           (% (+ long-count
  120.                 (car calendar-mayan-haab-at-epoch)
  121.                 (* 20 (1- (cdr calendar-mayan-haab-at-epoch))))
  122.              365))
  123.          (day (% day-of-haab 20))
  124.          (month (1+ (/ day-of-haab 20))))
  125.     (cons day month)))
  126.  
  127. (defun calendar-mayan-haab-difference (date1 date2)
  128.   "Number of days from Mayan haab DATE1 to next occurrence of haab date DATE2."
  129.   (mod (+ (* 20 (- (cdr date2) (cdr date1)))
  130.       (- (car date2) (car date1)))
  131.        365))
  132.  
  133. (defun calendar-mayan-haab-on-or-before (haab-date date)
  134.   "Absolute date of latest HAAB-DATE on or before absolute DATE."
  135.   (- date
  136.      (% (- date
  137.        (calendar-mayan-haab-difference
  138.         (calendar-mayan-haab-from-absolute 0) haab-date))
  139.     365)))
  140.  
  141. (defun calendar-next-haab-date (haab-date &optional noecho)
  142.   "Move cursor to next instance of Mayan HAAB-DATE. 
  143. Echo Mayan date if NOECHO is t."
  144.   (interactive (list (calendar-read-mayan-haab-date)))
  145.   (calendar-goto-date
  146.    (calendar-gregorian-from-absolute
  147.     (calendar-mayan-haab-on-or-before
  148.      haab-date
  149.      (+ 365
  150.         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  151.   (or noecho (calendar-print-mayan-date)))
  152.  
  153. (defun calendar-previous-haab-date (haab-date &optional noecho)
  154.   "Move cursor to previous instance of Mayan HAAB-DATE. 
  155. Echo Mayan date if NOECHO is t."
  156.   (interactive (list (calendar-read-mayan-haab-date)))
  157.   (calendar-goto-date
  158.    (calendar-gregorian-from-absolute
  159.     (calendar-mayan-haab-on-or-before
  160.      haab-date
  161.      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  162.   (or noecho (calendar-print-mayan-date)))
  163.  
  164. (defun calendar-mayan-haab-to-string (haab)
  165.   "Convert Mayan haab date (a pair) into its traditional written form."
  166.   (let ((month (cdr haab))
  167.         (day (car haab)))
  168.   ;; 19th month consists of 5 special days
  169.   (if (= month 19)
  170.       (format "%d Uayeb" day)
  171.     (format "%d %s"
  172.             day
  173.             (aref calendar-mayan-haab-month-name-array (1- month))))))
  174.  
  175. (defun calendar-mayan-tzolkin-from-absolute (date)
  176.   "Convert absolute DATE into a Mayan tzolkin date (a pair)."
  177.   (let* ((long-count (+ date calendar-mayan-days-before-absolute-zero))
  178.          (day (mayan-adjusted-mod
  179.                (+ long-count (car calendar-mayan-tzolkin-at-epoch))
  180.                13))
  181.          (name (mayan-adjusted-mod
  182.                 (+ long-count (cdr calendar-mayan-tzolkin-at-epoch))
  183.                 20)))
  184.     (cons day name)))
  185.  
  186. (defun calendar-mayan-tzolkin-difference (date1 date2)
  187.   "Number of days from Mayan tzolkin DATE1 to next occurrence of tzolkin DATE2."
  188.   (let ((number-difference (- (car date2) (car date1)))
  189.         (name-difference (- (cdr date2) (cdr date1))))
  190.     (mod (+ number-difference
  191.         (* 13 (mod (* 3 (- number-difference name-difference))
  192.                20)))
  193.      260)))
  194.  
  195. (defun calendar-mayan-tzolkin-on-or-before (tzolkin-date date)
  196.   "Absolute date of latest TZOLKIN-DATE on or before absolute DATE."
  197.   (- date
  198.      (% (- date (calendar-mayan-tzolkin-difference
  199.          (calendar-mayan-tzolkin-from-absolute 0)
  200.          tzolkin-date))
  201.     260)))
  202.  
  203. (defun calendar-next-tzolkin-date (tzolkin-date &optional noecho)
  204.   "Move cursor to next instance of Mayan TZOLKIN-DATE. 
  205. Echo Mayan date if NOECHO is t."
  206.   (interactive (list (calendar-read-mayan-tzolkin-date)))
  207.   (calendar-goto-date
  208.    (calendar-gregorian-from-absolute
  209.     (calendar-mayan-tzolkin-on-or-before
  210.      tzolkin-date
  211.      (+ 260
  212.         (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  213.   (or noecho (calendar-print-mayan-date)))
  214.  
  215. (defun calendar-previous-tzolkin-date (tzolkin-date &optional noecho)
  216.   "Move cursor to previous instance of Mayan TZOLKIN-DATE. 
  217. Echo Mayan date if NOECHO is t."
  218.   (interactive (list (calendar-read-mayan-tzolkin-date)))
  219.   (calendar-goto-date
  220.    (calendar-gregorian-from-absolute
  221.     (calendar-mayan-tzolkin-on-or-before
  222.      tzolkin-date
  223.      (1- (calendar-absolute-from-gregorian (calendar-cursor-to-date))))))
  224.   (or noecho (calendar-print-mayan-date)))
  225.  
  226. (defun calendar-mayan-tzolkin-to-string (tzolkin)
  227.   "Convert Mayan tzolkin date (a pair) into its traditional written form."
  228.   (format "%d %s"
  229.           (car tzolkin)
  230.           (aref calendar-mayan-tzolkin-names-array (1- (cdr tzolkin)))))
  231.  
  232. (defun calendar-mayan-tzolkin-haab-on-or-before (tzolkin-date haab-date date)
  233.   "Absolute date that is Mayan TZOLKIN-DATE and HAAB-DATE.
  234. Latest such date on or before DATE.
  235. Returns nil if such a tzolkin-haab combination is impossible." 
  236.   (let* ((haab-difference
  237.           (calendar-mayan-haab-difference
  238.            (calendar-mayan-haab-from-absolute 0)
  239.            haab-date))
  240.          (tzolkin-difference
  241.           (calendar-mayan-tzolkin-difference
  242.            (calendar-mayan-tzolkin-from-absolute 0)
  243.            tzolkin-date))
  244.          (difference (- tzolkin-difference haab-difference)))
  245.     (if (= (% difference 5) 0)
  246.         (- date
  247.            (mod (- date
  248.            (+ haab-difference (* 365 difference)))
  249.         18980))
  250.       nil)))
  251.  
  252. (defun calendar-read-mayan-haab-date ()
  253.   "Prompt for a Mayan haab date"
  254.   (let* ((completion-ignore-case t)
  255.          (haab-day (calendar-read
  256.                     "Haab kin (0-19): "
  257.                     '(lambda (x) (and (>= x 0) (< x 20)))))
  258.          (haab-month-list (append calendar-mayan-haab-month-name-array 
  259.                                   (and (< haab-day 5) '("Uayeb"))))
  260.          (haab-month (cdr
  261.                       (assoc
  262.                        (capitalize
  263.                         (completing-read "Haab uinal: "
  264.                                          (mapcar 'list haab-month-list)
  265.                                          nil t))
  266.                        (calendar-make-alist
  267.                         haab-month-list 1 'capitalize)))))
  268.     (cons haab-day haab-month)))
  269.  
  270. (defun calendar-read-mayan-tzolkin-date ()
  271.   "Prompt for a Mayan tzolkin date"
  272.   (let* ((completion-ignore-case t)
  273.          (tzolkin-count (calendar-read
  274.                          "Tzolkin kin (1-13): "
  275.                          '(lambda (x) (and (> x 0) (< x 14)))))
  276.          (tzolkin-name-list (append calendar-mayan-tzolkin-names-array nil))
  277.          (tzolkin-name (cdr
  278.                         (assoc
  279.                          (capitalize
  280.                           (completing-read "Tzolkin uinal: " 
  281.                                            (mapcar 'list tzolkin-name-list)
  282.                                            nil t))
  283.                          (calendar-make-alist
  284.                           tzolkin-name-list 1 'capitalize)))))
  285.     (cons tzolkin-count tzolkin-name)))
  286.  
  287. (defun calendar-next-calendar-round-date
  288.   (tzolkin-date haab-date &optional noecho)
  289.   "Move cursor to next instance of Mayan HAAB-DATE TZOKLIN-DATE combination.
  290. Echo Mayan date if NOECHO is t."
  291.   (interactive (list (calendar-read-mayan-tzolkin-date)
  292.                      (calendar-read-mayan-haab-date)))
  293.   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
  294.                tzolkin-date haab-date
  295.                (+ 18980 (calendar-absolute-from-gregorian
  296.                          (calendar-cursor-to-date))))))
  297.     (if (not date)
  298.         (error "%s, %s does not exist in the Mayan calendar round"
  299.                (calendar-mayan-tzolkin-to-string tzolkin-date)
  300.                (calendar-mayan-haab-to-string haab-date))
  301.       (calendar-goto-date (calendar-gregorian-from-absolute date))
  302.       (or noecho (calendar-print-mayan-date)))))
  303.  
  304. (defun calendar-previous-calendar-round-date
  305.   (tzolkin-date haab-date &optional noecho)
  306.   "Move to previous instance of Mayan TZOKLIN-DATE HAAB-DATE combination.
  307. Echo Mayan date if NOECHO is t."
  308.   (interactive (list (calendar-read-mayan-tzolkin-date)
  309.                      (calendar-read-mayan-haab-date)))
  310.   (let ((date (calendar-mayan-tzolkin-haab-on-or-before
  311.                tzolkin-date haab-date
  312.                (1- (calendar-absolute-from-gregorian
  313.                     (calendar-cursor-to-date))))))
  314.     (if (not date)
  315.         (error "%s, %s does not exist in the Mayan calendar round"
  316.                (calendar-mayan-tzolkin-to-string tzolkin-date)
  317.                (calendar-mayan-haab-to-string haab-date))
  318.       (calendar-goto-date (calendar-gregorian-from-absolute date))
  319.       (or noecho (calendar-print-mayan-date)))))
  320.  
  321. (defun calendar-absolute-from-mayan-long-count (c)
  322.   "Compute the absolute date corresponding to the Mayan Long Count C.
  323. Long count is a list (baktun katun tun uinal kin)"
  324.   (+ (* (nth 0 c) 144000)        ; baktun
  325.      (* (nth 1 c) 7200)          ; katun
  326.      (* (nth 2 c) 360)           ; tun
  327.      (* (nth 3 c) 20)            ; uinal
  328.      (nth 4 c)                   ; kin (days)
  329.      (-                          ; days before absolute date 0
  330.       calendar-mayan-days-before-absolute-zero)))
  331.  
  332. (defun calendar-mayan-date-string (&optional date)
  333.   "String of Mayan date of Gregorian DATE.
  334. Defaults to today's date if DATE is not given."
  335.   (let* ((d (calendar-absolute-from-gregorian 
  336.              (or date (calendar-current-date))))
  337.          (tzolkin (calendar-mayan-tzolkin-from-absolute d))
  338.          (haab (calendar-mayan-haab-from-absolute d))
  339.          (long-count (calendar-mayan-long-count-from-absolute d)))
  340.       (format "Long count = %s; tzolkin = %s; haab = %s"
  341.               (calendar-mayan-long-count-to-string long-count)
  342.               (calendar-mayan-tzolkin-to-string tzolkin)
  343.               (calendar-mayan-haab-to-string haab))))
  344.  
  345. (defun calendar-print-mayan-date ()
  346.   "Show the Mayan long count, tzolkin, and haab equivalents of date."
  347.   (interactive)
  348.   (message "Mayan date: %s"
  349.            (calendar-mayan-date-string (calendar-cursor-to-date t))))
  350.  
  351. (defun calendar-goto-mayan-long-count-date (date &optional noecho)
  352.   "Move cursor to Mayan long count DATE.  Echo Mayan date unless NOECHO is t."
  353.   (interactive
  354.    (let (lc)
  355.      (while (not lc)
  356.        (let ((datum
  357.               (calendar-string-to-mayan-long-count 
  358.                (read-string "Mayan long count (baktun.katun.tun.uinal.kin): "
  359.                             (calendar-mayan-long-count-to-string
  360.                              (calendar-mayan-long-count-from-absolute
  361.                                (calendar-absolute-from-gregorian
  362.                                 (calendar-current-date))))))))
  363.          (if (calendar-mayan-long-count-common-era datum)
  364.              (setq lc datum))))
  365.      (list lc)))
  366.   (calendar-goto-date
  367.    (calendar-gregorian-from-absolute
  368.     (calendar-absolute-from-mayan-long-count date)))
  369.   (or noecho (calendar-print-mayan-date)))
  370.               
  371. (defun calendar-mayan-long-count-common-era (lc)
  372.   "T if long count represents date in the Common Era."
  373.   (let ((base (calendar-mayan-long-count-from-absolute 1)))
  374.     (while (and (not (null base)) (= (car lc) (car base)))
  375.       (setq lc (cdr lc)
  376.             base (cdr base)))
  377.     (or (null lc) (> (car lc) (car base)))))
  378.  
  379. (defun diary-mayan-date ()
  380.   "Show the Mayan long count, haab, and tzolkin dates as a diary entry."
  381.   (format "Mayan date: %s" (calendar-mayan-date-string date)))
  382.  
  383. (provide 'cal-mayan)
  384.  
  385. ;;; cal-mayan.el ends here
  386.